Collaborative Movie Recommender

R-Version: [Default] [32-bit] C:\Program Files\R\R-4.1.0

In folgendem Notebook werden anhand des ‘Movielens’ Datensatzes aus dem Paket RecommenderLab verschiedene Recommender erstellt. Es werden verschiedene Recommender und verschiedene Ähnlichkeiten verwendet, um diese zu vergleichen und auszuwerten. Ziel ist es, ein möglichst guter Recommender zu erstellen und zu verstehen wie dieser funktioniert. Zudem soll verstanden werden wie dieser bewertet wird und was in diesem Falle ein ‘guter’ Recommender bedeutet.

Dieses Notebook konzentriert sich auf Erkenntnisse von Auswertungen und Vergleichen. Um eine Bessere Übersicht zu erhalten wurden grosse sich widerholende Codes in einem ‘helper.R’ file ausgelagert.

---

data wrangling

# Daten importieren
data(MovieLense)

# dataframe erstellen
movies <- as(MovieLense, "data.frame")
movies <- movies %>% mutate_if(is.character, as.factor)

# breite version des dataframe erstellen
movies_wider <- pivot_wider(
  movies,
  id_cols = user,
  names_from = item,
  values_from = rating,
  values_fill = NULL,
)

---

Explorative Datenanalyse

df_1 <- movies %>% group_by(item) %>%  summarize(mean_rating = mean(rating)) %>% sample_n(15) %>% arrange(desc(mean_rating))

ggplot(df_1, aes(y = reorder(item, +mean_rating), x = mean_rating)) +
  geom_col(alpha = 1, fill = 'steelblue') +
  scale_y_discrete(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  geom_text(aes(label=round(mean_rating,2)), hjust = 1.3, color = 'white') +
  labs(
    title = "Durchschnittliche Filmbewertung",
    subtitle = "Zufällige Stichprobe von 15 Filmen",
    y = element_blank(),    x = "Dirchschnittlich Bewertung in Sternen"
  ) +
  theme_classic() +
  theme(axis.text.x = element_blank(),
        axis.ticks.x = element_blank(),
        axis.line.x = element_blank(),
        text = element_text(size = 12) # text size
  )

Um einen ersten Überblick über die Daten zu erhalten wurde hier ein Plot von 15 zufällig gewählten Filmen samt der Durchschnittsbewertung geplottet.

---

1. Welches sind die am häufigsten geschauten Genres / Filme?

movies_genre <- MovieLenseMeta %>%
  rename(item = title)
movies_genre$url <- NULL
movies_genre[movies_genre == 0] <- NA
a <- which(movies_genre==1,arr.ind=TRUE)
movies_genre[a] <- names(movies_genre)[a[,"col"]]
movies_genre <- movies_genre %>%
  unite("genres", unknown:Western, sep= ",", 
        remove = TRUE, na.rm = TRUE)
genres<-merge(x=movies,y=movies_genre,by="item",all.x=TRUE)%>%
  mutate(genres = strsplit(as.character(genres), ",")) %>%
  unnest(genres)

df1a <- movies%>%
  group_by(item)%>%
  summarize(count=n())%>%
  ungroup()%>%
  arrange(desc(count))

df1a <- head(df1a, 10)

df1a %>%
  mutate(item = fct_reorder(item, count))%>%
  ggplot(aes(x = count, y = item))+
  geom_col(alpha = 1, fill = 'steelblue')+
  scale_y_discrete(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  geom_text(aes(label=round(count,2)), hjust = 1.3, color = 'white') +
  labs(
    title = "Meist bewertete Filme",
    y = element_blank(),    x = "Anzahl Bewertungen"
  ) +
  theme_classic() +
  theme(axis.text.x = element_blank(),
        axis.ticks.x = element_blank(),
        axis.line.x = element_blank(),
        text = element_text(size = 12) # text size
  )

Da in unserem Datensatz nur die Anzahl Ratings von Filmen gegeben ist, gehen wir davon aus, dass die meist bewerteten, auch die am meist geschauten Filme sind. In der Grafik sieht man die 10 meist bewerteten Filme.

df1b <- genres%>%
  group_by(genres)%>%
  summarize(count=n())%>%
  ungroup()%>%
  arrange(desc(count))

df1b%>%
  mutate(genres = fct_reorder(genres, count))%>%
  ggplot(aes(x = count, y = genres))+
  geom_col(alpha = 1, fill = 'steelblue')+
  geom_text(aes(label=round(count,2)), hjust = -0.2, color = 'black') +
  scale_y_discrete(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0), limits = c(0,45000)) +
  geom_text(aes(label=count,2), hjust = 1.3, color = 'white') +
  labs(
    title = "Meist bewertete Genres",
    y = element_blank(),    x = "Anzahl Bewertungen"
  ) +
  theme_classic() +
  theme(axis.text.x = element_blank(),
        axis.ticks.x = element_blank(),
        axis.line.x = element_blank(),
        text = element_text(size = 12) # text size
  )

Auch hier wird davon ausgegangen, dass die enres, welche am häufigsten bewertet wurden auch am häufigst geschaut wurden. In der Grafik ist zu sehen, dass Drama das top Genres ist, gefolgt von Comedy und Action.

---

2. Wie verteilen sich die Kundenratings gesamthaft und nach Genres?

ggplot(movies, aes(x = rating)) +
  geom_bar(alpha = 1, fill = 'steelblue') +
  geom_text(stat='count', aes(label=..count..), vjust=1.5, color = 'white') +
  scale_y_continuous(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  labs(
    title = "Verteilung Kundenratings gesamthaft",
    subtitle = paste("N = ", nrow(movies), " Bewertungen"),
    x = "Kundenbewertungen", 
    y = "Anzahl",
    fill = element_blank()
  ) +
  theme_classic() +
  theme(
    text = element_text(size = 12)
  )

In dieser Grafik ist die Verteilung der bewertungen zu sehen. Die Bewertungen 4 und 5 wirden klar am häufigsten vergeben, wobei 1 und 2 eher selten bewertet werden.

# get rating count per user, add as column for further processing
counts <- movies %>% group_by(user) %>% count()
movies2 <- merge(movies, counts, by="user")
movies_wider2 <- merge(movies_wider, counts, by="user")

# avoid users with almost no ratings, use median as threshold
median_count <- median(counts$n)

# get sample
set.seed(623)
movies_sample <- movies_wider2 %>% filter(n > median_count) %>% sample_n(5)

# create long table
movies_sample_long <- filter(movies2, user %in% movies_sample$user)

# drop item names, 
movies_sample_long <- subset(movies_sample_long, select = -c(item))

df2b <- genres%>%
  group_by(genres)
  
movies_sample_long_grouped <- movies_sample_long %>% group_by(user, rating) %>% summarise(rating_dens = length(user) / first(n), user = first(user), n=first(n), rating = first(rating))
  
ggplot(genres, aes(x = rating, fill = genres)) +
  geom_bar(alpha = 1, bins = 10) +
  facet_wrap(~genres)+
  scale_y_continuous(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  labs(
    title = "Verteilung Kundenratings nach Genres",
    subtitle = paste("N = ", nrow(movies), " Bewertungen"),
    x = "Durchschnittliche Bewertung", 
    y = "Anzahl",
    fill = element_blank()
  ) +
  theme(
    text = element_text(size = 12),
    legend.position = 'none'
  )

Hier ist zu sehen, dass das Genres Drama am meisten bewertet wurde, wobei Dokumentationen am wenigsten Bewertungen erhalten haben. Die Bewertungen pro Genres verteilen sich jeweils sehr ähnlich. Die Verteilungen der einzelnen Genres sind ebenfalls ähnlich verteilt wie die bewertungen gesamthaft.

---

3.Wie verteilen sich die mittleren Kundenratings pro Film?

df3 <- movies %>% 
  group_by(item) %>%  
  summarize(
    mean_rating = mean(rating),
    ratings = n()
  ) %>% 
  mutate(
    more_than_50 = ifelse(ratings >= 50, 'b) mehr als 50 Bewertungen', 'a) weniger als 50 Bewertugen')
  )

ggplot(df3, aes(x = mean_rating)) +
  geom_histogram(alpha = 1, fill = 'steelblue', binwidth = 0.06) +
  scale_y_continuous(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  labs(
    title = "Verteilung mittlere Kundenratings pro Film",
    subtitle = paste("N = ", nrow(movies), " Bewertungen"),
    x = "Durchschnittliche Bewertung", 
    y = "Dichte"
  ) +
  theme_classic() +
  theme(text = element_text(size = 12)
  )

In dieser Grafik ist die durchschnittliche Bewertung pro Film zu sehen, wobei auch hier zu sehen ist ,dass die die meisten Filme eine Durchschnittliche Bewertung von ca. 3 - 3.5 haben. Auffällig ist, dass bei den distinkten Werten (1, 2, 3, 4, & 5) aussreisser zu erkennen sind. Dies liegt an Filmen,welche nur wenige male oder nur einmal bewertet wurden.

ggplot(df3, aes(x = mean_rating, fill = more_than_50)) +
  geom_density(alpha = 0.5, bw = 0.08) +
  scale_y_continuous(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  labs(
    title = "Verteilung mittlere Kundenratings pro Film",
    subtitle = "N = 1664 Filme",
    x = "Durchschnittliche Bewertung", 
    y = "Dichte",
    fill = element_blank()
  ) +
  theme_classic() +
  theme(
    text = element_text(size = 12),
    legend.position = 'bottom'
  )

TODO: N = Anzahl bewertungen für Kategorie a & b

Für diese Grafik wurden die Filme in zwei gruppen unterteilt: Filme die weniger als 50 bewertungen erhalten haben, und Filme welche mehr als 50 Bewertungen erhalten haben. In der Grafik ist imernoch die durchschnittliche Bewertung dieser Filme zu sehen wobei deutlich erkannt werden kann, dass filme welche weniger bewertungen erhalten haben, tendenziell auch schlechter bewertet wurden.

---

4.Wie stark streuen die Ratings von individuellen Kunden?

# Number of ratings per user per rating value
movies_sample_long_grouped <- movies_sample_long %>% group_by(user, rating) %>% summarise(rating_dens = length(user) / first(n), user = first(user), n=first(n), rating = first(rating))

movies_span <- movies %>% group_by(user) %>% 
  summarize(mean = mean(rating), min = min(rating), max = max(rating), span = (max(rating) - min(rating)))

set.seed(123)

ggplot(movies_span  %>% group_by(span) %>% summarise(count = n()), aes(x=span, y=count)) +
  geom_col(fill = 'steelblue') +
  scale_y_continuous(limits = c(0,800), expand = c(0,0)) +
  geom_text(aes(label=round(count,2)), vjust = -0.7, color = 'black') +
  labs(
    title = "Spannweite Kundenratings",
    subtitle = "",
    x = "Spannweite", 
    y = "Anzahl User"
  )+
    theme_classic() + 
  theme(
    text = element_text(size = 12),
    legend.position = 'bottom'
  )

In diesen Grafiken sehen wir detailliertere Informationen über die Spannweite und den Mittelpunkt. In der ersten Übersicht ist die Spannweite und der Mittelpunkt einzelner Kunden dargestellt. Es fällt auf, dass trotz des teilweise relativ hohem Mittelwert alle Ratings von 1-5 abgegeben wurden. Ein rating von 5 wurde sozusagen immer abgegeben, 1 nicht immer. In der zweiten Übersicht ist die Spannweite aller Kunden dargestellt. Hier wird sichtbar, dass die meisten Kunden Bewertungen von 1-5 abgegeben haben (Spannweite=4), und nur weinige sehr homogen bewertet haben (Spannweite = 1-2). Eine kleine Spannweite kann hier auch aufgetreten sein, da diese User sehr wenige Bewertungen abgegeben haben.

---

5.Welchen Einfluss hat die Normierung der Ratings pro Kunde auf deren Verteilung?

movies_sample_long_grouped <- movies %>% group_by(rating) %>% summarise(rating_dens = n())

ggplot(movies_sample_long_grouped, aes(x=rating, y = rating_dens)) + 
  geom_col(fill = 'steelblue') +
  scale_y_continuous(expand = c(0,0)) +
  geom_text(aes(label=round(rating_dens,2)), vjust = 1.5, color = 'white') +
  labs(
    title = "Häufigkeit der Kundenbewertungen",
    subtitle = paste("N =",  nrow(movies), " Bewertungen"),
    x = "User Bewertung (1-5)", 
    y = "Anzahl Bewertungen",
    fill = element_blank()
  ) +
  scale_fill_manual("legend", values = c("cyan3", "cyan4", "darkolivegreen3", "darkolivegreen", "coral4")
                    )+
  theme_classic() + 
  theme(
    text = element_text(size = 12),
    legend.position = 'bottom'
  )

MovNorm <- normalize(MovieLense, method="Z-score")
mov <- as(MovNorm, "data.frame")

ggplot(mov, aes(x=rating)) + 
  geom_histogram(fill = 'steelblue', bins = 70) +
  scale_y_continuous(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  labs(
    title = "Häufigkeit der Kundenbewertungen",
    subtitle = paste("N = ", nrow(mov), "Bewertungen"),
    x = "User Bewertung Normiert", 
    y = "Anzahl Bewertungen",
    fill = element_blank()
  ) +
  scale_fill_manual("legend", values = c("cyan3", "cyan4", "darkolivegreen3", "darkolivegreen", "coral4")
                    )+
  theme_classic() + 
  theme(
    text = element_text(size = 12),
    legend.position = 'bottom'
  )

Die Ratings sind nun ungefähr Normalverteilt mit einem Durchschnittsrating von 0 und einer Standardabweichung von 1. Erkennbar ist, dass die Verteilung rechtssteil und linksschief ist, also mehrheitlich positive Bewertungen abgegeben wurden. Durch die Normierung der Daten werden die Ratings jedes Users auf dieselbe Verteilung gestaucht, wodurch man die Verteilung aller Daten analysieren kann. Dadurch hat man beispielsweise die Möglichkeit die durchschnittliche Bewertungstendenz herauszufinden.

---

6.Welche strukturellen Charakteristika (z.B. Sparsity) und Auffälligkeiten zeigt die User Item Matrix?

image(as(MovieLense, "dgCMatrix"))

In dieser Grafik werden werden die Bewertungen von Users (Row) den Filmen (Column) gegenübergestellt. Die Achsenbeschriftung konnte nicht besser speizifiziert werden.

Users mit tiefen ID’s und Filme mit hohen ID’s weisen weniger ratings auf. Filme mit tiefer ID jedoch sehr viele. Dies erklärt die nicht vorhandenen Datenpunkte in der Grafik oben rechts Auffallend ist, dass es einige wenige User gibt, die fast alle Filme bewertet haben (erkennbar durch die horizontalen scharzen Striche). Dies scheinen sehr aktive Bewerter zu sein. Viele Users haben jedoch nur einen kleinen Teil der Filme bewertet. Bei den Filmen ist eine ähnliche Tendenz wahrzunehmen, jedoch sind die vertikalen Striche breiter. Möglicherweise sind dort einige beliebte Filme zusammengefasst.

sparcity <- sum(is.na(movies_wider[,-1])) / prod(dim(movies_wider))
sparcity

[1] 0.9360962

TODO: nur 6.4% der Daten haben Values / sind non NA’s- ein User hat im durchschnitt 6.4% der Filme bewertet -> schöner schreiben

Die Matrix ist sehr sparce. Fast 94% der Daten bestehen aus NA Werten. Dies wurde so erwartet, da es unwahrscheinlich ist dass ein Film von allen users akiv bewertet wird, oder dass ein User alle Filme ansieht und auch bewertet.

---

Datenreduktion

#Data reduction
dense_reduction <- data_reduction_dense(MovieLense)
dense_user_reduction <- data_reduction_dense_user(MovieLense)
random_reduction <- data_reduction_random(MovieLense)

#same as dense reduction
ratingMatrix <- data_reduction_dense(MovieLense)

matrices <- c('Original Matrix (MovieLense)', 'dense_reduction', 'dense_user_reduction', 'random_reduction')
sparsities <- c(get_sparsity(MovieLense), get_sparsity(dense_reduction), get_sparsity(dense_user_reduction), get_sparsity(random_reduction))

df_sparsity <- data.frame(matrix = matrices, sparsity = sparsities)

#Plot Data reduction
ggplot(df_sparsity, aes(x=matrix, y = sparsity)) + 
  geom_col(fill = 'steelblue') +
  coord_flip() +
  scale_y_continuous(expand = c(0,0)) +
  geom_text(aes(label=round(sparsity,2)), hjust = 1.3, color = 'white') +
  labs(
    title = "Sparsity der verschiedenen Datenreduktionen",
    x = element_blank(), 
    y = "Sparcity in Prozent",
    fill = element_blank()
  ) +
  theme_classic() + 
  theme(
    text = element_text(size = 12),
    legend.position = 'bottom'
  )

TODO: Besserer beschreib zu den reduktionen - wieso welche reduktionen + wieso diese sparcity Für die dense_reduction sinkt die Sparsity von 93.67% auf 75.80%. Für die dense_user_reduction sinkt die Sparsity von 93.67% auf 88.18%. Für die random_reduction bleibt die Sparsity praktisch unverändert. Sie sinkt von 93.67% auf 92.75%.

p1 <- image(dense_reduction, main = "Raw Ratings for Dense Reduction")
p2 <- image(dense_user_reduction, main = "Raw Ratings for Dense User Reduction")
p3 <- image(random_reduction, main = "Raw Ratings for Random Reduction")

grid.arrange(p1, p2, p3, ncol = 3, nrow = 1)

TODO: mehr beschreibung

Man sieht sehr klar, dass die matrix nun deutlich weniger sparse ist.

p1 <- show_change_of_rating_distribution(MovieLense, dense_reduction, 'Für dense_reduction, N alte Matrix = 1664 Filme, N neue Matrix = 700 Filme')
p2 <- show_change_of_rating_distribution(MovieLense, dense_user_reduction, 'Für dense_user_reduction, N alte Matrix = 1664 Filme, N neue Matrix = 700 Filme')
p3 <- show_change_of_rating_distribution(MovieLense, random_reduction, 'Für random_reduction, N alte Matrix = 1664 Filme, N neue Matrix = 700 Filme')

grid.arrange(p1, p2, p3, ncol = 2, nrow = 2)

TODO: beschreibung

---

Analyse Ähnlichkeitsmatrix

1. Zerlege den reduzierten MovieLense Datensatz in ein disjunktes Trainings- und Testdatenset im Verhältnis 4:1

#both <- split_dataset(ratingMatrix, 0.8)
#train <- both[[1]]
#test <- both[[2]]

#print('Trainingsdatenset:')
#dim(train)
#print('')
#print('Testdatenset:')
#dim(test)

e <- evaluationScheme(dense_reduction, method="split", train=0.8, k=1, given=0)

The following users do not have enough items leaving no given items: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, 308, 309, 310, 311, 312, 313, 314, 315, 316, 317, 318, 319, 320, 321, 322, 323, 324, 325, 326, 327, 328, 329, 330, 331, 332, 333, 334, 335, 336, 337, 338, 339, 340, 341, 342, 343, 344, 345, 346, 347, 348, 349, 350, 351, 352, 353, 354, 355, 356, 357, 358, 359, 360, 361, 362, 363, 364, 365, 366, 367, 368, 369, 370, 371, 372, 373, 374, 375, 376, 377, 378, 379, 380, 381, 382, 383, 384, 385, 386, 387, 388, 389, 390, 391, 392, 393, 394, 395, 396, 397, 398, 399, 400

train <- getData(e, "train")
test <- getData(e, 'unknown')

TODO: ignore warning + evtl. löschen?

---

2. Trainiere ein IBCF Modell mit 30 Nachbarn und Cosine Similarity

# train IBCF recommender
rec <- Recommender(train, method = "IBCF", param=list(method="Cosine", k=30, normalize = NULL, na_as_zero = TRUE)) #normalize = 'center'
# predict top 10 movies for 100 users
pre <- predict(rec, test, n = 10)

---

3. Bestimme die Verteilung der Filme, welche bei IBCF für paarweise Ähnlichkeitsvergleiche verwendet werden

model <- getModel(rec)
colSum <- colSums(model$sim > 0)

df <- as.data.frame(colSum)

# add index column
df <- cbind(item = rownames(df), df)
rownames(df) <- 1:nrow(df)

ggplot(df, aes(x = colSum)) +
  geom_histogram(alpha = 1, fill = 'steelblue', binwidth = 2) +
  scale_y_continuous(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  labs(
    title = "Verteilung der Anzahl ähnlicher Filme",
    # subtitle = paste("N = ", nrow(df3), " Filme"),
    x = "Anzahl Filme bei denen der Film als Nachbar auftaucht", 
    y = "Häufigkeit"
  ) +
  theme_classic() +
  theme(text = element_text(size = 12)
  )

TODO: gute beschreibung

---

4. Bestimme die Filme, die am häufigsten in der Cosine-Ähnlichkeitsmatrix auftauchen und analysiere deren Vorkommen und Ratings im reduzierten Datensatz

df1 <- df %>% arrange(desc(colSum)) %>% head(10)

ggplot(df1, aes(x = colSum, y = reorder(item, +colSum)))+
  geom_col(alpha = 1, fill = 'steelblue')+
  scale_y_discrete(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  geom_text(aes(label=round(colSum,2)), hjust = 1.3, color = 'white') +
  labs(
    title = "Häufigste Filme in Cosine-Ähnlichkeitsmatrix",
    y = element_blank(),
    x = "Anzahl Filme in deren Nachbarschaft der Film ist"
  ) +
  theme_classic() +
  theme(axis.text.x = element_blank(),
        axis.ticks.x = element_blank(),
        axis.line.x = element_blank(),
        text = element_text(size = 12) # text size
  )

TODO: Beschreibung

top10 <- as.list(df1)$item

data <- as(ratingMatrix, "data.frame")
data1 <- data %>%
  group_by(item) %>%
  summarize(mean_rating = mean(rating)) %>%
  arrange(desc(mean_rating)) %>%
  mutate(category = ifelse(item %in% top10, 'Häufigste 10 Filme', 'Restliche Filme'))

ggplot(data1, aes(x = mean_rating, fill = category)) +
  geom_density(alpha = 0.5, bw = 0.05) +
  scale_y_continuous(expand = c(0,0)) +
  scale_x_continuous(expand = c(0,0)) +
  labs(
    title = "Verteilung mittlere Kundenratings pro Film",
    x = "Durchschnittliche Bewertung",
    y = "Dichte",
    fill = element_blank()
  ) +
  theme_classic() +
  theme(
    text = element_text(size = 12),
    legend.position = c(.14, .93)
  )

TODO: mehr beschreibung Es fällt auf, dass die häufigsten Filme allgemein sehr gut bewertet werden.

---

##Analyse Top-N Listen - IBCF vs. UBCF ####1.Berechne Top-15 Empfehlungen für Testkunden mit IBCF und UBCF

rec_ibcf <- Recommender(train, method = "IBCF", param=list(method="Cosine", k=30, normalize = NULL, na_as_zero = TRUE))
topn_ibcf <- predict(rec_ibcf, test, n = 15)
topn_ibcf_list <- as(topn_ibcf, "list")
topn_ibcf_df <- as.data.frame(do.call(rbind, topn_ibcf_list))

rec_ubcf <- Recommender(train, method = "UBCF", param=list(method="Cosine", normalize = NULL))
topn_ubcf <- predict(rec_ubcf, test, n = 15)
topn_ubcf_list <- as(topn_ubcf, "list")
topn_ubcf_df <- as.data.frame(do.call(rbind, topn_ubcf_list))

---

####2.Vergleiche die Top-15 Empfehlungen und deren Verteilung und diskutiere Gemeinsamkeiten und Unterschiede zwischen IBCF und UBCF für alle Testkunden.

#compare most occurring items

ibcf_top <- head(sort(colCounts(topn_ibcf), decreasing = TRUE))
ibcf_top_df <- as.data.frame(ibcf_top)
ibcf_top_df <- tibble::rownames_to_column(ibcf_top_df, "movies")
names(ibcf_top_df)[names(ibcf_top_df) == 'ibcf_top'] <- 'n_appearances'


ubcf_top <- head(sort(colCounts(topn_ubcf), decreasing = TRUE))
ubcf_top_df <- as.data.frame(ubcf_top)
ubcf_top_df <- tibble::rownames_to_column(ubcf_top_df, "movies")
names(ubcf_top_df)[names(ubcf_top_df) == 'ubcf_top'] <- 'n_appearances'

p1 <- plot_most_occ_item(ibcf_top_df, 'ibcf')
p2 <- plot_most_occ_item(ubcf_top_df, 'ubcf')

grid.arrange(p1, p2, ncol = 2, nrow = 1)

Auffällig ist, dass im UBCF die Filme, welche am häufigsten in den Top-15 Empfehlungen auftauchen, wesentlich öfters vorkommen als diese, die im IBCF als am meist vorkommende Filme definiert sind. Ebenfalls auffallend ist, dass die beiden Recommender sehr verschiedene Vorschläge machen. Für die meist vorkommenden Filme in den TopNListen gibt es hier keine Überschneidung.

#get distribution of intersect for each user
#intersect of top 15 recommendations IBCF vs UBCF
#list_comp_ibcf_ubcf <- vector(mode = "list", length = length(topn_ibcf_list))
list_comp_ibcf_ubcf <- list()
for (n in 1:length(topn_ibcf_list)) {
  intersection <- length(intersect(unlist(topn_ibcf_list[n]), unlist(topn_ubcf_list[n]))) / 15
  list_comp_ibcf_ubcf <- append(list_comp_ibcf_ubcf, intersection)
}

comp_ibcf_ubcf <- data.frame(matrix(unlist(list_comp_ibcf_ubcf), nrow=length(list_comp_ibcf_ubcf), byrow=TRUE))
colnames(comp_ibcf_ubcf) <- c('intersect')
comp_ibcf_ubcf <- comp_ibcf_ubcf %>% group_by(intersect) %>% summarise(count = n()) %>% ungroup()
comp_ibcf_ubcf$intersect <- as.character(round(comp_ibcf_ubcf$intersect, 2))

ggplot(comp_ibcf_ubcf, aes(x = intersect, y = count)) +
  geom_col(alpha = 1, fill = 'steelblue') +
  geom_text(aes(label=count), vjust=1.5, color = 'white') +
  scale_y_continuous(expand = c(0,0)) +
  labs(
    title = "Verteilung der überschneidung der empfohlenen Filme",
    # subtitle = paste("N = ", nrow(df3), " Filme"),
    x = "Überschneidung in %", 
    y = "Häufigkeit"
  ) +
  theme_classic() +
  theme(text = element_text(size = 12)
  )

TODO: beschreib

---

Analyse Top-N Listen - Ratings

Vergleiche den Anteil übereinstimmender Empfehlungen der Top-15 Liste für IBCF vs UBCF, beide mit ordinalem Rating und Cosine Similarity für alle Testkunden

#ibcf recommender with Jaccard similarity
rec_ibcf_jac <- Recommender(train, method = "IBCF", param=list(method="Jaccard", k=30, normalize = NULL, na_as_zero = TRUE))
topn_ibcf_jac <- predict(rec_ibcf_jac, test, n = 15)
topn_ibcf_jac_list <- as(topn_ibcf_jac, "list")

#ubcf recommender with Jaccard similarity
rec_ubcf_jac <- Recommender(train, method = "UBCF", param=list(method="Jaccard", normalize = NULL))
topn_ubcf_jac <- predict(rec_ubcf_jac, test, n = 15)
topn_ubcf_jac_list <- as(topn_ubcf_jac, "list")

comparison <- matrix(ncol = 2, nrow = 3)

#intersect of top 15 recommendations IBCF vs UBCF cosine similarity
comp_ord_cos<- 0
for (n in 1:length(topn_ibcf_list)) {
  intersection <- length(intersect(unlist(topn_ibcf_list[n]), unlist(topn_ubcf_list[n]))) / 15
  comp_ord_cos <- comp_ord_cos + intersection
}
comparison[1,1] <- 'ibcf cos - ubcf cos'
comparison[1,2] <- round(comp_ord_cos / length(topn_ibcf_list), 2)


#intersect of top 15 recommendations IBCF vs UBCF Jaccard similarity
comp_bin_jac<- 0
for (n in 1:length(topn_ibcf_jac_list)) {
  intersection <- length(intersect(unlist(topn_ibcf_jac_list[n]), unlist(topn_ubcf_jac_list[n]))) / 15
  comp_bin_jac <- comp_bin_jac + intersection
}
comparison[2,1] <- 'ibcf cos - ubcf jac'
comparison[2,2] <- round(comp_bin_jac / length(topn_ibcf_jac_list), 2)

#intersect of top 15 recommendations UBCF Cosine Similarity vs UBCF Jaccard similarity
comp_cos_jac<- 0
for (n in 1:length(topn_ubcf_jac_list)) {
  intersection <- length(intersect(unlist(topn_ubcf_jac_list[n]), unlist(topn_ubcf_list[n]))) / 15
  comp_cos_jac <- comp_cos_jac + intersection
}
comparison[3,1] <- 'ubcf cos - ubcf jac'
comparison[3,2] <- round(comp_cos_jac / length(topn_ubcf_jac_list), 2)

comparison <- data.frame(comparison)
comparison

ggplot(comparison, aes(x = X1, y = X2)) +
  geom_col(alpha = 1, fill = 'steelblue') +
  #geom_text(aes(label=count), vjust=1.5, color = 'white') +
  scale_y_discrete(expand = c(0,0)) +
  labs(
    title = "Verteilung der überschneidung der empfohlenen Filme",
    # subtitle = paste("N = ", nrow(df3), " Filme"),
    x = "Überschneidung in %", 
    y = "Häufigkeit"
  ) +
  theme_classic() +
  theme(text = element_text(size = 12)
  )

TODO: ForLoop TODO: für alle Datenreduktionen + 3 plots in grid (width = 15)

---

##Analyse Top-N Listen - IBCF vs SVD ####1.Vergleiche wie sich der Anteil übereinstimmender Empfehlungen der Top-15 Liste für IBCF vs verschiedene SVD Modelle verändert, wenn die Anzahl der Singulärwerte für SVD von 10 auf 20, 30, 40, 50 verändert wird

#dense_reduction, dense_user_reduction, random_reduction

datasets = c(dense_reduction, dense_user_reduction, random_reduction)
datasetnames = c('dense_reduction', 'dense_user_reduction', 'random_reduction')
k = c(10, 20, 30, 40, 50)
dense_reduction

400 x 700 rating matrix of class ‘realRatingMatrix’ with 67765 ratings.

output <- data.frame('comparison' = character(), 'intersection' = numeric(), 'dataset' = character())
colnames(output) <- c('comparison', 'intersection', 'dataset')

for (d in 1:length(datasets)){
  e <- evaluationScheme(datasets[[d]], method="split", train=0.8, k=1, given=0)
  train <- getData(e, "train")
  test <- getData(e, 'unknown')
  
  for (n in k){
    rec_svd <- Recommender(train, method = "SVD", param=list(k = n))
    topn_svd <- predict(rec_svd, test, n = 15)
    topn_svd_list <- as(topn_svd, "list")
  
    comp_ibcf_svd <- 0
    for (i in 1:length(topn_ibcf_list)) {
      intersection <- length(intersect(unlist(topn_ibcf_list[i]), unlist(topn_svd_list[i]))) / 15
      comp_ibcf_svd <- comp_ibcf_svd + intersection
    }
    out <- c(paste('IBCF vs. SVD', n), round(comp_ibcf_svd / length(topn_ibcf_list), digits = 4), as.character(datasetnames[[d]]))
    output[nrow(output) + 1,] = out
    }
}

The following users do not have enough items leaving no given items: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, 308, 309, 310, 311, 312, 313, 314, 315, 316, 317, 318, 319, 320, 321, 322, 323, 324, 325, 326, 327, 328, 329, 330, 331, 332, 333, 334, 335, 336, 337, 338, 339, 340, 341, 342, 343, 344, 345, 346, 347, 348, 349, 350, 351, 352, 353, 354, 355, 356, 357, 358, 359, 360, 361, 362, 363, 364, 365, 366, 367, 368, 369, 370, 371, 372, 373, 374, 375, 376, 377, 378, 379, 380, 381, 382, 383, 384, 385, 386, 387, 388, 389, 390, 391, 392, 393, 394, 395, 396, 397, 398, 399, 400The following users do not have enough items leaving no given items: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, 308, 309, 310, 311, 312, 313, 314, 315, 316, 317, 318, 319, 320, 321, 322, 323, 324, 325, 326, 327, 328, 329, 330, 331, 332, 333, 334, 335, 336, 337, 338, 339, 340, 341, 342, 343, 344, 345, 346, 347, 348, 349, 350, 351, 352, 353, 354, 355, 356, 357, 358, 359, 360, 361, 362, 363, 364, 365, 366, 367, 368, 369, 370, 371, 372, 373, 374, 375, 376, 377, 378, 379, 380, 381, 382, 383, 384, 385, 386, 387, 388, 389, 390, 391, 392, 393, 394, 395, 396, 397, 398, 399, 400The following users do not have enough items leaving no given items: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, 308, 309, 310, 311, 312, 313, 314, 315, 316, 317, 318, 319, 320, 321, 322, 323, 324, 325, 326, 327, 328, 329, 330, 331, 332, 333, 334, 335, 336, 337, 338, 339, 340, 341, 342, 343, 344, 345, 346, 347, 348, 349, 350, 351, 352, 353, 354, 355, 356, 357, 358, 359, 360, 361, 362, 363, 364, 365, 366, 367, 368, 369, 370, 371, 372, 373, 374, 375, 376, 377, 378, 379, 380, 381, 382, 383, 384, 385, 386, 387, 388, 389, 390, 391, 392, 393, 394, 395, 396, 397, 398, 399, 400

output

ggplot(output, aes(x = comparison, y = intersection, fill = dataset)) +
  geom_col(alpha = 1, position = position_dodge()) +
  #geom_text(aes(label=count), vjust=1.5, color = 'white') +
  scale_y_discrete(expand = c(0,0)) +
  labs(
    title = "Verteilung der überschneidung der empfohlenen Filme",
    # subtitle = paste("N = ", nrow(df3), " Filme"),
    x = "Überschneidung in %", 
    y = "Häufigkeit"
  ) +
  theme_classic() +
  theme(text = element_text(size = 12),
        axis.text.x = element_text(angle = 60, hjust = 1)
  )

TODO: beschreib

---

Wahl des optimalen Recommenders

Verwende für die Evaluierung 10-fache Kreuzvalidierung,

Als erstes stellte sich die Frage, ob precision, recall, oder ein kombinierter F1-Score als performance Metrik gewählt werden sollte. Precision ist umgekehrt proportional zu false positive, recall zu false negative Voraussagen. Da es in diesem Fall wichtiger ist, die gemachten Empfehlungen korrekt vorauszusagen, wurde Precision als Performance Metrik definiert. Als zweite Wahl würden wir auf den F1-Score zurückggreifen. Dieser setzt sich aus der Kombination beider Petriken precision und recall zusammen.

Der Parameter goodRating stellt die binäre Grenze dar, bei welcher ein rating als “positiv” bezeichnet werden kann. Wird der Wert höher gesetzt, sinkt die precision und der recall steigt. In dieser Modelloptimierung wurde definiert, dass alle Ratings ab 3 als positiv klassiert werden sollten.

In dieser Grafik ist die precision der novelty der trainierten Modelle gegenübergestellt. Dabei wurde jedes Modell für n-recommendations trainiert und dargestellt. Es wurde 10 fold cross validation verwendet. Die dargestellten Werte visualisieren das arithmetische Mittel der Scores auf den jeweils 10 Testdatensätzen. Dadurch können die Modelle und Parameter unabhängig von der Struktur der Daten miteinander verglichen werden.

Als erstes wurde sichtbar, dass die Modellwahl mehr Einfluss auf die precision des Modell hatte als die n-recommendations. Deshalb wurde nur SVD und popular für weitere Hyperparameteroptimierung angeschaut.

Das SVD Modell wurde hier für verschiedene k’s trainiert. Dabei wurde klar, dass ein k~5 die beste precision voraussagt. Jedoch kommt das Modell nicht annähernd an die precision von popular heran.

Das beste daraus resultierende Modell ist in dem Falle “popular items” mit n=10 Voraussagen.

Das popular Modell besitzt keine Hyperparameter für die Optimierung. Deshalb wird hier SVD bezüglich Hyperparameter k und n im Detail optimiert.

Für das Modell SVD ist die Precision am besten, wenn k=4 ist und n=10. Zudem wurde festgestellt, dass je nach Seed Position k=5 besser sein kann. Die precision des Modells mit optimierten Hyperparameter ist immernoch tiefer, als die des popular Modells.

---

Implementierung Ähnlichkeitsmatrix

Als erstes wird hier ein sample aus 100 zufällig gewähten Filmen gezogen.

# reduce samples to 100 users
sample_sim <- sample_similarity(movies)
# generate matrix equivalent
sample_sim_matrix <- as(sample_sim, 'matrix')
# convert back to real rating matrix
sample_sim_rating <- as(sample_sim, "realRatingMatrix")
sample_sim_rating_norm <- normalize(sample_sim_rating)
sample_sim_wide_norm <- as(sample_sim_rating_norm, 'matrix')
# create wide versionwide version
sample_sim_wide <- pivot_wider(
  sample_sim,
  id_cols = user,
  names_from = item,
  values_from = rating,
  values_fill = NULL,
)

sample_sim_wide

Hier wird hier ein IBCF recommender gebaut, um die cosine similarity Matrix der Filme mithilfe von Recommenderlab zu erstellen. Dabei wurden folgende Parameter eingestellt: - k: in Recommenderlab wird die similarity zu k Nachbaren berechnet. Damit die Implementierung mit der Eigenen überein stimmen kann, muss dieser Wert gleich gross oder grösser als die Anzahl Items in den Daten sein. Da wir 100 Filme ausgewählt haben, wird k=100 gewählt.

• normalize: Recommenderlab normalisiert die Ratings standardmässig. Damit dies mit der eigenen Implementierung überein stimmt, wird die Normalisierung hier deaktiviert.

• na_as_zero: NA’s werden im Recommender Berechnung standardmässig ausgelassen. Da in der eigenen Imeplentierung die NA’s auch auf 0 gesetzt wurden, wurde dies hier auch gemacht. Hätte noch eine Normalisierung stattgefunden, wäre dies beispielsweise bei normalize=‘center’ den Mittelwert.

k_value = dim(sample_sim_rating)[2]
print(paste("K-Wert: ", k_value))

[1] "K-Wert:  100"

start.time <- Sys.time()
rec <- Recommender(sample_sim_rating, method = "IBCF", param=list(method="Cosine", k=k_value, normalize = NULL, na_as_zero = TRUE))
end.time <- Sys.time()
elapsed.time <- round((end.time - start.time), 3)
print(elapsed.time)

Time difference of 0.08 secs

similarity <- as.matrix(rec@model$sim)
#image(similarity)
plot_sim(similarity)

Es wird sichtbar, dass die Diagonalwerte eine andere Farbe aufweisen. Leider kann man die Similarities aufgrund der Menge von Datenpunkten nicht wirklich vergleichen. Werden die ersten Werte visualisiert, wird jedoch klar dass die Diagonaleinträge 0 anstatt 1 sind. Dies ist jedoch nicht weiter tragisch, da diese Daten keine Informationen tragen. Sie können deshalb ignoriert werden.

similarity[1:3, 1:3]

                                    20,000 Leagues Under the Sea (1954) Ace Ventura: Pet Detective (1994) Airheads (1994)
20,000 Leagues Under the Sea (1954)                           0.0000000                         0.2446432       0.1596641
Ace Ventura: Pet Detective (1994)                             0.2446432                         0.0000000       0.4807474
Airheads (1994)                                               0.1596641                         0.4807474       0.0000000

# sort colums alphabetical without user column indexes
sample_sim_zero <- sample_sim_wide[-1][, order(colnames(sample_sim_wide[-1])),]
# convert to matrix
sample_sim_zero <- as(sample_sim_zero, 'matrix')
# replace nas with 0 (non adjusted cosine similarity)
sample_sim_zero[is.na(sample_sim_zero)] <- 0

start.time <- Sys.time()
cosine_sim_matrix <- cosine_sim2(t(sample_sim_zero), t(sample_sim_zero))
end.time <- Sys.time()
elapsed.time <- round((end.time - start.time), 3)
print(elapsed.time)

Time difference of 0.047 secs

plot_sim(cosine_sim_matrix)

Hier wurde die cosine similarity als Matrix Berechnung implementiert. Der Zeitaufwand der Berechnung ist etwas geringer als bei der Implementierung von Recommenderlab. Dies ist der Fall, da im recommenderlab Package noch weitere Schritte durchlaufen werden, um beispielsweise für k Nachbaren zu optimieren. Wie man erkennen kann, sind die Ausprägungen der Similarities ähnlich zur Recommenderlab Implementierung, bis auf die Diagonalwerte. Diese werden deshalb noch durch 0 ersetzt.

diag(cosine_sim_matrix) <- 0
cosine_sim_matrix[1:3, 1:3]

                                    20,000 Leagues Under the Sea (1954) Ace Ventura: Pet Detective (1994) Airheads (1994)
20,000 Leagues Under the Sea (1954)                           0.0000000                         0.2446432       0.1596641
Ace Ventura: Pet Detective (1994)                             0.2446432                         0.0000000       0.4807474
Airheads (1994)                                               0.1596641                         0.4807474       0.0000000

Auch die ersten Zahlenwerte stimmen mit dem Print der similarities von recommenderlab überein.

Nun werden die Zahlenwerte der zwei berechneten similarity Matrizen verglichen.

sum(abs(cosine_sim_matrix - similarity))

[1] 2.17576e-13

Wie hier sichtbar wird, ist die Summe der absoluten Differenzen aller Werte der Matrizen verschwindend klein. Die Matrizen sind also bis auf den Fliesskommafehler identisch.

Als nächstes wird die jaccard similarity berechnet. Dafür werden die Ratings zuerst binärisiert. Als Splitkriterium wurde ein Rating von 3 gewählt, was bedeutet dass alle Ratings ab 3 als True dargestellt werden, alle Ratings darunter als False.

# binarize matrix and make split at a rating of 3
sample_sim_bin <- as(binarize(as(sample_sim_rating, "realRatingMatrix"), minRating=3), "matrix") * 1

# replace nas with 0 (no adjusted cosine similarity)
#wide_matrix[is.na(wide_matrix)] <- 0

# ibcf, because columns are taken here
# row count

start.time <- Sys.time()
jac_own <- jaccard_sim2(t(sample_sim_bin), t(sample_sim_bin))
end.time <- Sys.time()
elapsed.time <- round((end.time - start.time), 3)
print(elapsed.time)

Time difference of 0.037 secs

plot_sim(jac_own)

#dim(wide_matrix)

jac_own[1:3, 1:3]

                                    20,000 Leagues Under the Sea (1954) Ace Ventura: Pet Detective (1994) Airheads (1994)
20,000 Leagues Under the Sea (1954)                          1.00000000                         0.1120000      0.02631579
Ace Ventura: Pet Detective (1994)                            0.11200000                         1.0000000      0.11842105
Airheads (1994)                                              0.02631579                         0.1184211      1.00000000

Auch bei der Implementierung der Jaccard Similarity ist dank Matriximplementation der Zeitaufwand relativ gering. Hier fällt jedoch auf, dass auf der Diagonalen Lücken bestehen.

print(paste("NA value count in similarity matrix:", sum(is.na(jac_own))))

[1] "NA value count in similarity matrix: 4"

jac_own[43:45, 43:45]

                    Heavyweights (1994) Homage (1995) Houseguest (1994)
Heavyweights (1994)                 1.0             0               0.1
Homage (1995)                       0.0           NaN               0.0
Houseguest (1994)                   0.1             0               1.0

jac_own[38:40, 38:40]

                         Gaslight (1944) Gordy (1995) Great Escape, The (1963)
Gaslight (1944)                1.0000000            0                0.1007194
Gordy (1995)                   0.0000000          NaN                0.0000000
Great Escape, The (1963)       0.1007194            0                1.0000000

print(paste(sum(sample_sim_bin[,44]), "people have rated <Homage (1995)> 3 or higher."))

[1] "0 people have rated <Homage (1995)> 3 or higher."

print(paste(sum(sample_sim_bin[,39]), "people have rated <Gordy (1995)> 3 or higher."))

[1] "0 people have rated <Gordy (1995)> 3 or higher."

Bei Durchsuchung des Datensatzes ist auffallend, dass diese Filme nur nagative Bewertungen enthalten. Durch die Implementierung der Jaccard Similarity entsteht dadurch im Nenner eine 0, was zu einer jaccard similarity von NA führt.

Als Nächstes wird die normierte Cosine Ähnlichkeitsmatrix berechnet.

mean_total <- mean(sample_sim_wide_norm, na.rm=TRUE)

for(col_i in 1:dim(sample_sim_wide_norm)[2])
{
  # replace nas with 0 (non adjusted cosine similarity)
  mean_col = mean(sample_sim_wide_norm[,col_i], na.rm=TRUE)
  #print(mean_col)
  sample_sim_wide_norm[is.na(sample_sim_wide_norm[,col_i]), col_i] <- mean_col

}

start.time <- Sys.time()
cosine_sim_norm <- cosine_sim2(t(sample_sim_wide_norm), t(sample_sim_wide_norm))
end.time <- Sys.time()
elapsed.time <- round((end.time - start.time), 3)
print(elapsed.time)

Time difference of 0.046 secs

plot_sim(cosine_sim_norm)

In dieser Darstellung ist die normierte cosine similarity dargestellt. Für die Normierung wurde min-max Normailisierung gewählt, mit dem Mittelwert der ratings pro Film als NA Ersatz. Dadurch entsteht wie erwartet grundsätzlich eine höhere similarity, wessen Werte sich zwischen 0 und 1 ansiedeln.

p1 <- plot_sim(cosine_sim_matrix)
p2 <- plot_sim(jac_own)
p3 <- plot_sim(cosine_sim_norm)

grid.arrange(p1, p2, p3, ncol = 3, nrow = 1)

Die unnormalisierten Cosine und Jaccard Ähnlichkeitsmatrizen sind sich sehr ähnlich. Sie weisen ähnliche strukturelle Eigenschaften auf. Die Jaccard Ähnlichkeitsmatrix enthält generell etwas tiefere Werte und ist deshalb heller. Es werden jedoch einzelne Punkte sichbar, welche eine Ähnlichkeit von 1 aufweisen.

print(jac_own[25:28, 25:27])

                               Dadetown (1995) Damsel in Distress, A (1937) Designated Mourner, The (1997)
Dadetown (1995)                              1                            0                              1
Damsel in Distress, A (1937)                 0                            1                              0
Designated Mourner, The (1997)               1                            0                              1
Doom Generation, The (1995)                  0                            0                              0

print(sample_sim_wide[,'Designated Mourner, The (1997)'] %>% drop_na())

print(sample_sim_wide[,'Dadetown (1995)'] %>% drop_na())

TODO: klarere darstellung evtl?

Dies ist beispielsweise bei den Filmen ‘Designated Mourner, The (1997)’ und ‘Dadetown (1995)’ der Fall. Diese Filme wurde drei, bzw. ein Mal bewertet. Der Rest der Werte ist jeweils auf 0 gesetzt. Deshalb wird die Cosine Ähnlichkeit zwischen diesen Werten kaum eine Aussage treffen können. Diese Werte sind deshalb von niedriger Bedeutung.

Die normalisierte Cosine Ähnlichkeitsmatrix ist etwas anders in der Struktur. Dadurch, dass die Mittelwerte der jeweiligen Filmbewertungen durch die fehlenden Daten ein hohes Gewicht auf die Daten haben, entstehen generell grössere Abstände zwischen den Bewertungen einzelner Filme. Diese werden sichtbar durch Streifen. Dadurch liegt ein stärkerer Fokus auf den Unterschieden der Filmbewertungen im Allgemeinen und weniger auf den Unterschieden einzelner Ratings. Dadurch verschwinden die similarities einzelner Filme ein wenig und die Grafik ist schwerer zu lesen. Wäre die Matrix weniger sparce, würde diese Impuation nicht so stark ins Gewicht fallen und die Darstellung könnte besser abgelesen werden. In diesem Falle ist diese Grafik jedoch nicht gut geeignet.

---

Implementierung Top-N Metriken

Catalog coverage and System-level novelty

rec <- Recommender(train, method = "IBCF", param=list(method="Cosine", k=30, normalize = NULL, na_as_zero = TRUE)) #normalize = 'center', 'Z-score'

df_coverage <- show_coverage(c(5,10,15,20,25,30), rec)
df_novelty <- show_novelty(c(5,10,15,20,25,30))

df_combined <- inner_join(df_coverage, df_novelty, by = 'N')

Coverage: Summe aller unterschiedlichen Produkte, welche in den Top-N Listen aller KundInnen insgesamt auftauchen dividiert durch die Menge aller Produkte. Novelty: Mittel der Shannon Information der Popularität der Produkte in der Top-N Liste gemittelt über alle KundInnen.

ggplot(data=df_combined, aes(x=coverage, y=novelty, group=1)) +
  geom_line() +
  geom_text(aes(label=N), vjust=-.25, hjust=-.05, show.legend = FALSE) +
  labs(
    title = "Coverage gegenüber Novelty für verschiedene N",
    y = "Novelty",
    x = "Coverage"
  ) +
  theme(text = element_text(size = 12))

TODO: das ganze im selben plot für verschiedene reduktionen darstellen + text + verschiedene Datenreduktionen

---

Implementierung Top-N Monitor

Fixiere 20 zufällig gewählte Testkunden für alle Modellvergleiche

Bestimme den Anteil der Top-N Empfehlung nach Genres pro Kunde

TODO: Hier auch 3 mal? - nein TODO: IBCF im titel erwähnen

rec <- Recommender(train, method = "IBCF", param=list(method="Cosine", k=30, normalize = NULL, na_as_zero = TRUE))
df_user_genres_top_n <- create_df_user_genres_top_n(rec, genres)
show_genre_fraction_plot(df_user_genres_top_n, df_user_genres_top_n$count_top_n, "Anteil Genres in Top-N Empfehlung von 20 zuf. Kunden")

TODO: text

Auf diesem Plot ist die Unterschiedliche Verteilung der Genres in den Top-N Empfehlungen für die verschiedenen Kunden zu sehen. Es fällt auf, dass bei diesem Recommender durchaus verschiedenartige Verteilungen bei den Genres für die verschiednen Nutzer auftreten.

Bestimme pro Kunde den Anteil nach Genres seiner Top-Filme (=Filme, welche vom Kunden die besten Bewertungen erhalten haben)

df_user_genres_best <- create_df_user_genres_best(movies, df_user_genres_top_n, genres)
show_genre_fraction_plot(df_user_genres_best, df_user_genres_best$count_best, "Anteil Genres der bestbewerteten Filme von 20 zuf. Kunden")

Auf diesem Plot ist die Unterschiedliche Verteilung der Genres bei den bestbewerteten Filmen für die verschiedenen Kunden zu sehen. Bestbewertet bedeutet in diesem Fall, dass die Bewertung eines Filmes mindestens 0.5 höher sein muss, als die Durchschnittliche Bewertung des Nutzers. Es fällt auf, dass bei den Top-N Empfehlungen allgemein Action zu wenig empfohlen wurde. Comedy hingegen wurde häufig zu viel empfohlen. Bei genauerem betrachten fällt auf, dass dieser Recommeder beispielsweise bei Kunde Nr. 38 auf die Genres bezogen sehr schlechte Empfehlungen macht.

Vergleiche pro Kunde Top-Empfehlungen und Top-Filmen nach Genres

df_user_genres_best <- create_df_user_genres_best(movies, df_user_genres_top_n, genres)

rec <- Recommender(train, method = "IBCF", param=list(method="Cosine", k=30, normalize = NULL, na_as_zero = TRUE))
df_user_genres_top_n <- create_df_user_genres_top_n(rec, genres)
df_user_genres <- create_df_user_genres(df_user_genres_top_n, df_user_genres_best)
show_cleveland_dot_plot(df_user_genres, 'IBCF Recommender mit Cosine Similarity')

Auf diesem Plot ist ersichtlich welche Genres der IBCF Recommender mit Cosine Similarity für die 20 Kunden eher zu wenig oder zu viel empfiehlt. Beispielsweise Comedy macht bei den bestbewerteten Filmen im Durchschnitt ungefähr 12% aus, erscheint in den Top-N Empfehlungen jedoch zu etwa 21%.

rec <- Recommender(train, method = "UBCF", param=list(method="Jaccard", normalize = NULL))
df_user_genres_top_n <- create_df_user_genres_top_n(rec, genres)
df_user_genres <- create_df_user_genres(df_user_genres_top_n, df_user_genres_best)
show_cleveland_dot_plot(df_user_genres, 'UBCF Recommender mit Jaccard Similarity')

rec <- Recommender(train, method = "POPULAR")
df_user_genres_top_n <- create_df_user_genres_top_n(rec, genres)
df_user_genres <- create_df_user_genres(df_user_genres_top_n, df_user_genres_best)
show_cleveland_dot_plot(df_user_genres, 'Popular Recommender')

TODO: add plot for svd recommender

Definiere eine Qualitätsmetrik für Top-N Listen und teste sie

algorithms <- list(
  "IBCF cosine" = list(name="IBCF", param=list(k = 30, method = "cosine", normalize = NULL, na_as_zero = TRUE), desc = 'IBCF Recommender mit Cosine Similarity'),
  "UBCF Jaccard" = list(name="UBCF", param=list(method = "jaccard"), desc = 'UBCF Recommender mit Jaccard Similarity'),
  "Popular" = list(name="POPULAR", param=NULL, desc = 'Popular Recommender')
)

errors <- vector()
algos <- vector()
for (algo in algorithms) {
  rec <- Recommender(train, method = algo$name, param=algo$param)
  df_user_genres_top_n <- create_df_user_genres_top_n(rec, genres)
  df_user_genres <- create_df_user_genres(df_user_genres_top_n, df_user_genres_best)
  error <- compute_mean_absolute_percentage_error(df_user_genres)
  algos <- c(algos, algo$desc)
  errors <- c(errors, error)
}

df_error <- data.frame(description = algos, error = errors)


ggplot(df_error, aes(x=description, y = error)) + 
  geom_col(fill = 'steelblue') +
  coord_flip() +
  scale_y_continuous(expand = c(0,0)) +
  geom_text(aes(label=error), hjust=1.5, color = 'white') +
  labs(
    title = "Mittlerer absoluter prozentualer Fehler der \nGenre-Anteile in den Top-N Empfehlungen",
    x = element_blank(), 
    y = "Mittlerer absoluter prozentualer Fehler",
    fill = element_blank()
  ) +
  theme_classic() + 
  theme(
    text = element_text(size = 12),
    legend.position = 'bottom'
  )

abs(df1_drama - df2_drama) + abs(df1_actions - df2_action) + …